home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / ODE / obj_main < prev    next >
Encoding:
Text File  |  1991-10-24  |  10.6 KB  |  347 lines
  1. \ ODE - Object Oriented Development Environment
  2. \
  3. \ This file contains the basis for the Object Oriented
  4. \ Development Environment used by HMSL.  The essential
  5. \ words like :CLASS and <SUPER are defined here.
  6. \
  7. \ Notes:
  8. \  RELOCATION: When addresses are stored in the dictionary,
  9. \  they are stored in a relocatable form.  For JForth
  10. \  this means they are stored as standard relative addresses.
  11. \  For Mach2, they are stored as relocatable tokens
  12. \  expressed as a segment and an offset.
  13. \
  14. \ Data Structures:    ( offsets are from PFA )
  15. \  CLASS Definition Structure
  16. \  offset     name           contents
  17. \    0     OB_SIZE        size of object
  18. \    4     OB_#METHODS    number of methods
  19. \    8     OB_VALID_KEY   key for class validation
  20. \   12     OB_SUPER       rel pointer to base of super class
  21. \   16     OB_LAST_IVAR   rel pointer to cfa of last of linked ivars
  22. \   20     OB_CFAS        base of the CFA array, method_0 CFA
  23. \   24       ---          method_1 CFA
  24. \   28       ---          method_2 CFA
  25. \            etc.
  26.  
  27. \ INSTANCE VARIABLE Definition Structure
  28. \  offset     contents
  29. \    0      offset in object
  30. \    4      size of instance variable
  31. \
  32. \ INSTANCE OBJECT Definition Structure
  33. \  offset     name          contents
  34. \    0     OBI_OFFSET     offset in parent object
  35. \    4     OBI_SIZE       size of object
  36. \    8     OBI_PREVIOUS   link to previous Instance Object
  37. \   12     OBI_REL_CLASS  rel pointer to class
  38. \
  39. \ OBJECT Structure
  40. \  offset     contents
  41. \    0      rel pointer to OB_CFAS of associated class.
  42. \    4      start of instance variable space.
  43. \
  44. \ Parameter description:
  45. \    ABS_        = Prefix for Forth normal address.
  46. \    REL_        = Prefix for relocatable token.
  47. \    _OBJ_BASE   = Base of object, contains REL_CFA_BASE
  48. \    _CFA_BASE   = Address of first CFA in method array.
  49. \    _CLASS_BASE = Base of class, offsets added to get to #ivars
  50. \    OBJ_TOKEN   = Identifying token for object.
  51. \    METHOD_INDEX = index of method in cfa table.
  52. \    METHOD_CFA  = CFA for a method.
  53. \
  54. \ Author: Phil Burk
  55. \ Copyright 1986 Phil Burk
  56. \
  57. \ MOD: PLB 7/14/86 Converted late binding to use relative addresses.
  58. \ MOD: PLB 7/15/86 Added pairing checks to :M - ;M
  59. \ MOD: PLB 7/17/86 Added OB.INIT, must be called before any objects.
  60. \ MOD: PLB 7/25/86 Fixed stack leftovers bug, added " ! " to :CLASS.
  61. \ MOD: PLB 8/16/86 Put error checking in BIND operation.
  62. \ MOD: PLB 9/15/86 Converted to work with JForth
  63. \      Put conditional compilation for OB.IVAR techniques.
  64. \ MOD: PLB 9/16/86 Broke up into smaller files:
  65. \      OBJ_STACK , OBJ_MAIN , OBJ_BINDING , OBJ_METHODS .
  66. \      Added :STRUCT .
  67. \ MOD: PLB 10/20/86 Moved :STRUCT to c_struct.
  68. \ MOD: PLB 10/23/86 Made MAC mods.
  69. \ MOD: PLB 11/29/86 Relocatable method tokens, CREATE MI-NEXT
  70. \ MOD: PLB 2/20/87  Put 0 OB-STATE ! in MRESET
  71. \ MOD: PLB 5/13/87  Zero ivars when instantiated, add os.push.
  72. \ MOD: PLB 9/3/87   Add INHERITANCE.OF
  73. \ MOD: PLB 9/8/87   Use structures for CLASS and INSTANCE OBJECTs.
  74. \      Support Instance Objects.
  75. \ MOD: PLB 1/13/88 Add relocation for Mac for Instance Objects
  76. \ MOD: PLB 4/26/88 Add USE->REL to OB.PRELOAD.CFAS for Mac.
  77. \      MDH 7/5/88   Modified MAKE.OBJECT to set CLASS_BIT in SFA
  78. \      MDH 7/15/88  Modified :CLASS to set :CLASS_BIT in SFA
  79. \ 00001 PLB 9/20/91 Sped up OB.SET.NAME on Mac by not doing PFA->NFA
  80.  
  81. ANEW TASK-OBJ_MAIN
  82.  
  83. \ Error Detection and reporting. ================================
  84. : OB.BAD.METHOD ( abs_obj_base -- , Give error for undefined meth.)
  85.     pfa->nfa id.
  86.     " OB.BAD.METHODS" " Illegal method for object!"
  87.     ER_FATAL  ER.REPORT
  88. ;
  89.  
  90. : OB.PRELOAD.CFAS ( abs_cfa_base N -- , Load N methods into table. )
  91.     0 DO ( FOR EACH METHOD )
  92.         dup i cell* +
  93.         'c ob.bad.method use->rel swap !
  94.     LOOP drop
  95. ;
  96.  
  97. .NEED OB-STATE
  98.     U: OB-STATE  ( Compilation state. )
  99.     U: OB-CURRENT-CLASS  ( ABS_CLASS_BASE of current class )
  100.     1 constant OB_DEF_CLASS   ( defining a class )
  101.     2 constant OB_DEF_STRUCT  ( defining a structure )
  102. .THEN
  103.  
  104. \ Method index counter ========================================
  105. \ Every method is assigned a unique index when it is declared.
  106. \ This index is used to lookup the appropriate CFA in a table
  107. \ kept in the CLASS .
  108.  
  109. CREATE MI-NEXT 0 ,
  110.  
  111. \ Class definition  =========================================
  112. \ Define CLASS structure ----------------------------------
  113.  
  114. U: OB-INSIDE-:M   ( flag for pairs checking )
  115.  
  116. \ Structures of Class and Instance Object Definition.
  117. :STRUCT OB.CLASS
  118.     LONG OB_SIZE
  119.     LONG OB_#METHODS
  120.     LONG OB_VALID_KEY
  121.     LONG OB_SUPER
  122.     LONG OB_LAST_IVAR    ( relative address of last ivar )
  123.     LONG OB_CFAS
  124. ;STRUCT
  125.  
  126. :STRUCT OB.INSTANCE.OBJECT
  127.     LONG OBI_OFFSET
  128.     LONG OBI_SIZE
  129.     LONG OBI_PREVIOUS    ( relative )
  130.     LONG OBI_REL_CLASS
  131. ;STRUCT
  132.  
  133. \ An unlikely number, used for recognizing valid classes.
  134. hex 518279AF CONSTANT OB_VALID.KEY decimal
  135.  
  136. \ ----------------------------------------------------------
  137. V: OB-SELF-CFAS ( abs_cfa_base, for current class, fake instance )
  138.  
  139. host=mac .IF
  140. \ Set the IV-NAME instance variable in OBJECTS to
  141. \ point to the NFA of the Instance Object Definition
  142. : OB.SET.NAME ( addr_inst_obj_def addr_object -- , set IV-NAME )
  143. \ This is a rather nasty thing to do - SO DON'T DO IT - TOO SLOW ON MAC!
  144. \    swap pfa->nfa swap cell+ !   \  PFA->NFA is very slow! 00001
  145.     swap drop " INSTOBJ" swap cell+ !
  146. ;
  147. .ELSE
  148. : OB.SET.NAME ( addr_inst_obj_def addr_object -- , set IV-NAME )
  149.     swap pfa->nfa swap cell+ !
  150. ;
  151. .THEN
  152.  
  153. : OB.SETUP ( addr_obj abs_class_base -- , Setup data in object )
  154. \ Recursively setup instance objects.
  155.     dup ..@ ob_last_ivar
  156.     BEGIN dup ( is it zero )
  157.     WHILE ( -- addr_obj abs_class_base rel_addr_inst_obj_def )
  158.         rel->use dup @ ( get offset )
  159.         3 pick + ( calc address of instance object )
  160.         2dup >r >r
  161.         over ..@ obi_rel_class rel->use   ( class of instance object )
  162.         recurse
  163.         r> r> ob.set.name
  164.         ..@ obi_previous
  165.     REPEAT drop
  166. \
  167. \ Compile rel_cfa_base at obj_base.
  168.     ( -- obj_base class_base )
  169.     .. ob_cfas 2dup use->rel swap ! ( set methods pointer in object)
  170.     ( -- obj_base cfa_base )
  171.     swap os.push           ( push object address for method )
  172.     @ rel->use execute     ( execute INIT: method )
  173.     os.drop
  174. ;
  175.  
  176. #HOST_AMIGA_JFORTH .IF
  177. : MAKE.OBJECT ( abs_class_base -- , Instantiate an object. )
  178.     CREATE  ( make object header )
  179. \
  180. \ Mark as CLASS definition for CLONE...
  181. \
  182.     latest name> cell-   dup @ CLASS_BIT or  swap !
  183. \
  184. \
  185.         here swap                ( addr_object abs_class_base )
  186.         dup ..@ ob_size allot    ( make room for ivars )
  187.         2dup ..@ ob_size erase   ( zero out ivar space )
  188.         ob.setup
  189.         IMMEDIATE
  190.     DOES> ( addr )
  191.         [compile] aliteral
  192. ;
  193. .ELSE
  194. : MAKE.OBJECT ( abs_class_base -- , Instantiate an object. )
  195.     CREATE  ( make object header )
  196.         here swap         ( addr_object abs_class_base )
  197.         dup @ allot       ( make room for ivars )
  198.         2dup @ erase      ( zero out ivar space )
  199.         ob.setup
  200.     DOES> use->rel    ( run time action of object )
  201. ;
  202. .THEN
  203.  
  204. : MAKE.INSTANCE.OBJECT  ( abs_class_base -- , Template for embedded object )
  205.     CREATE here >r
  206.         dup @ ob.make.member
  207. \ Link new instance object to previous instance object.
  208.         ob-current-class @ ..@ ob_last_ivar ( relocatable ) ,
  209. \ Update ob_last_ivar field in current class.
  210.         r> use->rel ( -- abs_class_base rel_inst_ivar )
  211.         ob-current-class @ ..! ob_last_ivar
  212. \ Save pointer to class, OB_REL_CLASS .
  213.         use->rel ,
  214.     DOES>
  215.         @ ( get offset )
  216.         os+ use->rel  ( -- rel_instance_object )
  217. ;
  218.  
  219. : :CLASS (  -- , Create a class with N methods )
  220. \ Check pairs
  221.     ob-state @
  222.     IF " :CLASS" " Previous :STRUCT or :CLASS unterminated!"
  223.         er_warning er.report
  224.     THEN
  225.     ob_def_class ob-state !     ( set pair flags )
  226.     false ob-inside-:m !
  227. \
  228. \ Create new class defining word.
  229.     CREATE
  230. \
  231. \
  232. \ Added mdh...
  233. \
  234.     [ #HOST_AMIGA_JFORTH .IF ]
  235. \
  236. \ Mark as :CLASS definition for CLONE...
  237. \
  238.         latest name> cell-   dup @ :CLASS_BIT or  swap !   [ .THEN ]
  239. \
  240. \
  241.             here dup ob-current-class !  ( set current )
  242.             .. ob_cfas ob-self-cfas !       ( for self binding )
  243. \ Fill fields in CLASS, must match order as defined !
  244.             cell ,                  ( OB_IVAR_SPACE , initial ivar offset )
  245.             mi-next @ dup ,         ( OB_#METHODS , # methods allowed )
  246.             ob_valid.key ,          ( OB_VALID_KEY , key for validation )
  247.             0 ,                     ( OB_SUPER , space for superclass pointer )
  248.             0 ,                     ( OB_LAST_IVAR , space for pointer to last )
  249.             here over cell* allot   ( OB_CFAS , make room for CFAS )
  250.         swap ob.preload.cfas     ( put error method in for safety)
  251.     DOES>  ob-state @ ob_def_class =
  252.         IF make.instance.object
  253.         ELSE make.object
  254.         THEN
  255. ;
  256.  
  257. \ INHERITANCE =============================================
  258. ( Methods will be inherited by copying CFAS into CFA array. )
  259. V: OB-SUPER-CFAS   ( abs_cfa_base of SUPER CLASS )
  260. V: OB-DOOPER-CFAS  ( abs_cfa_base of SUPER's SUPER CLASS )
  261.  
  262. : OB.SET.DOOPER    ( -- , set dooper cfas based on super )
  263.     ob-super-cfas @       ( base of cfas )
  264.     ob_cfas - ..@ ob_super rel->use ( superclass of superclass )
  265.     ob_cfas + ob-dooper-cfas !
  266. ;
  267.  
  268. : <SUPER ( <WORD> ---- , COPY METHODS )
  269.     ho.find.pfa NOT
  270.     IF " <SUPER" " CLASS NOT FOUND"
  271.         ER_FATAL ER.REPORT
  272.     THEN ( -- super-pfa )
  273.     ob-current-class @ ( -- super-pfa class-pfa )
  274.  
  275. \ Save superclass pointer in class.
  276.     2dup swap use->rel swap  ( make relative )
  277.     ..! ob_super
  278. \
  279. \ Save pointer to last linked ivar object.
  280.     over ..@ ob_last_ivar
  281.     over ..! ob_last_ivar
  282. \
  283. \ Increment IVAR offset to include superclass' ivars
  284.         2dup
  285.         swap ..@ ob_size ( -- sp cp cp s# , space for super's ivars )
  286.         over ..@ ob_size cell- + ( -- sp cp cp c#, 1 cell for class*)
  287.         swap ..! ob_size
  288.  
  289. \ Copy method cfas from superclass
  290.         over ..@ ob_#methods      ( sp cp #-inherited-methods )
  291.         cell*                     ( sp cp #bytes , calc bytes to copy )
  292.         rot  .. ob_cfas           ( cp #bytes super_cfas )
  293. \
  294. \ Save super_cfas for later binding.
  295.         dup ob-super-cfas !
  296.         rot .. ob_cfas            ( #bytes super_cfas class_cfas )
  297.         rot cmove                 ( copy methods )
  298.         ob.set.dooper
  299. ;
  300.  
  301. : ;CLASS ( -- , terminate class )
  302.     ob-state @ ob_def_class = NOT
  303.     IF " ;CLASS" " Missing :CLASS above" er_fatal er.report
  304.     THEN
  305.     0 ob-state !
  306. ;
  307.  
  308. : INHERITANCE.OF ( <class> -- , list superclasses of class )
  309.     ho.find.pfa
  310.     IF  cr
  311.         BEGIN  ..@ ob_super if.rel->use dup
  312.         WHILE  dup pfa->nfa id. space space cr? ?pause
  313.         REPEAT drop
  314.     THEN cr
  315. ;
  316.  
  317. : OB.IS.INSTANCE? ( abs_pfa_object_def abs_class_base -- flag , Instance Object?)
  318. \ Scans list of instance variables in class for match.
  319.     0 -rot   ( default answer = false )
  320.     ..@ ob_last_ivar
  321.     BEGIN  dup
  322.     WHILE
  323.         rel->use 2dup =
  324.         IF >r >r drop true ( change answer )
  325.             r> rdrop 0
  326.         ELSE
  327.             ..@ obi_previous
  328.         THEN
  329.     REPEAT
  330.     2drop
  331. ;
  332.  
  333.  
  334. \ Tools for debugging ODE
  335. : 'P ( <created_data_structure> -- pfa )
  336.     [compile] 'c cfa->pfa
  337. ;
  338.  
  339. : METHOD@ ( method_index pfa_class -- abs_method_cfa )
  340.     .. ob_cfas
  341.     swap cell* + @ rel->use
  342. ;
  343.  
  344. : GET.METHOD ( method_index <class> -- method_cfa )
  345.     'p method@
  346. ;
  347.